home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-03
/
pb3brows.zip
/
BROWSE.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-04-02
|
5KB
|
169 lines
'******************************************************************************
'* PowerBasic 3 module for fileviewing *
'* uses BROWSASM.BAS en VID&KBD.BAS *
'* (c) Hans Lunsing - 04/1993 *
'******************************************************************************
$DIM ARRAY
$ERROR ALL -
$LIB LPT -, COM -, GRAPH -, FULLFLOAT -, IPRINT -
$OPTIMIZE SIZE
$OPTION CNTLBREAK -, GOSUB -
$STRING 1
DEFINT A-Z
$INCLUDE "GENERAL.BI"
' Cachesize &H4000 (decimaal 16384) words, 32768 bytes
' N.B.: cachesize must be even !
%CacheSize = &H4000
' Assembler routines:
DECLARE SUB InitBrowseFile (BYVAL WORD, BYVAL WORD, BYVAL WORD, BYVAL WORD)
DECLARE SUB ShowFile (BYVAL INTEGER, BYVAL INTEGER, BYVAL INTEGER, _
BYVAL INTEGER, BYVAL INTEGER)
DECLARE SUB LineDown ()
DECLARE SUB LineUp ()
DECLARE SUB PageDown (BYVAL INTEGER)
DECLARE SUB PageUp (BYVAL INTEGER)
DECLARE SUB EndFile (BYVAL INTEGER)
DECLARE SUB HomeFile ()
DECLARE SUB ExitBrowseFile ()
BrowseStatusRow:
DATA " │ Browse: Home End PgUp Pgdn <-> Back: Enter or Esc "
SUB Browse (FileName$, BYVAL Top, BYVAL Bottom, BYVAL TextAttr, BYVAL Status, _
BYVAL StatusAttr, BYVAL Scroll, BYVAL WordStar, ErrCode) PUBLIC
' Functie: bekijk tekstbestand op scherm
DIM FileNum AS INTEGER
DIM BeginOffset AS INTEGER ' offset in bytes first line to use
DIM FirstText AS INTEGER ' first text usable screenline
DIM LastText AS INTEGER ' last text usable screenline
DIM BeginColumn AS INTEGER ' First textcolumn on the screen
DIM EndColumn AS INTEGER ' First textcolummn NOT on screen
DIM TextRows AS INTEGER ' Textlines on screen
DIM StatusRow AS INTEGER ' Statusline
DIM StatusLine AS STRING ' Cintents of the statusline
DIM SaveFg AS INTEGER ' Current foregroundcolor
DIM SaveBg AS INTEGER ' Current backgroundcolor
DIM FgT AS INTEGER, BgT AS INTEGER' Fore/background textcolor
DIM FgS AS INTEGER, BgS AS INTEGER' Fore/background statuslinecolor
ErrCode = 0
ON LOCAL ERROR RESUME NEXT
IF pbvScrnMode <> 0 THEN
ErrCode = 250 ' videomode not supported
EXIT SUB
END IF
FileNum = FREEFILE
OPEN FileName$ FOR INPUT AS #FileNum
ErrCode = ERRTEST
IF ErrCode > 0 THEN EXIT SUB
GOSUB GetBoundaries
IF LastText < FirstText THEN EXIT SUB
GOSUB GetParameters
ClearLines FirstText, LastText
IF StatusRow THEN
GOSUB PlaceStatusLine
END IF
DIM Cache(1 TO %CacheSize) ' Cache for filecontents
BeginColumn = 0
TextRows = LastText - FirstText + 1
InitBrowseFile FILEATTR(FileNum, 2), VARSEG(Cache(1)), VARPTR(Cache(1)), _
%CacheSize
DO
ShowFile FirstText, TextRows, BeginColumn, TextAttr, Filter
SELECT CASE GetKey
CASE -81 'PgDn
PageDown TextRows
CASE -73 'PgUp
PageUp TextRows
CASE -80 'DownArrow
LineDown
CASE -72 'Uparrow
LineUp
CASE -79 'End
EndFile TextRows
CASE -71 'Home
BeginColumn = 0
HomeFile
CASE 9, -77 'Tab or RightArrow
BeginColumn = BeginColumn + Scroll
CASE -15, -75 'Shift-Tab or LeftArrow
IF BeginColumn THEN
BeginColumn = BeginColumn - Scroll
END IF
CASE 13, 27 'Enter or Escape
ExitBrowseFile
EXIT DO
END SELECT
LOOP
CLOSE #FileNum
EXIT SUB
GetBoundaries:
IF Top < 1 THEN
Top = 1
ELSEIF Top > pbvScrnRows THEN
Top = pbvScrnRows
END IF
IF Bottom < Top OR Bottom > pbvScrnRows THEN
Bottom = pbvScrnRows
END IF
StatusRow = 0
FirstText = Top
LastText = Bottom
SELECT CASE Status
CASE < 0
StatusRow = Bottom
LastText = Bottom - 1
CASE > 0
StatusRow = Top
FirstText = Top + 1
END SELECT
RETURN
GetParameters:
IF WordStar THEN
Filter = &H7F
ELSE
Filter = &HFF
END IF
IF TextAttr = 0 THEN
LOCATE FirstText, 1
TextAttr = GetActiveColor
END IF
IF Scroll = 0 THEN
Scroll = 8
END IF
RETURN
PlaceStatusLine:
' Plaats statusregel
RESTORE BrowseStatusRow
READ StatusLine$
FOR i = LEN(FileName$) TO 1 STEP -1
IF INSTR("\:", MID$(FileName$, i, 1)) THEN EXIT FOR
NEXT i
MID$(StatusLine$, 2) = MID$(FileName$, i + 1)
IF StatusAttr THEN
FgS = StatusAttr AND &HF
BgS = StatusAttr \ &H10
ELSE
FgT = TextAttr AND &HF
BgT = TextAttr \ &H10
InvertColor FgT, BgT, FgS, BgS
END IF
GetAttr SaveFg, SaveBg
Attr FgS, BgS
LOCATE StatusRow, 1, 0
PRINT StatusLine$;
Attr SaveFg, SaveBg
RETURN
END SUB